home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xldbug.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  9.4 KB  |  342 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xldebug.c
  5. * RCS:          $Header: xldbug.c,v 1.6 91/03/24 22:24:31 mayer Exp $
  6. * Description:  xlisp debugging support
  7. * Author:       David Michael Betz; Niels Mayer
  8. * Created:      
  9. * Modified:     Fri Oct  4 03:38:15 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xldbug.c,v 1.6 91/03/24 22:24:31 mayer Exp $";
  43.  
  44. #ifdef WINTERP
  45. #include <X11/Intrinsic.h>
  46. #endif
  47. #include "xlisp.h"
  48.  
  49. /* external variables */
  50. extern int xldebug;
  51. extern int xlsample;
  52. extern LVAL s_debugio,s_unbound;
  53. extern LVAL s_tracenable,s_tlimit,s_breakenable;
  54. extern LVAL true;
  55. extern char buf[];
  56.  
  57. /* external routines */
  58. extern char *malloc();
  59.  
  60. /* forward declarations */
  61. /* FORWARD LVAL stacktop(); */ /* NPM: commented this out since it is not defined anywhere */
  62.  
  63. /* xlabort - xlisp serious error handler */
  64. xlabort(emsg)
  65.   char *emsg;
  66. {
  67.     xlsignal(emsg,s_unbound);
  68.     xlerrprint("error",NULL,emsg,s_unbound);
  69.     xlbrklevel();
  70. }
  71.  
  72. /* xlbreak - enter a break loop */
  73. xlbreak(emsg,arg)
  74.   char *emsg; LVAL arg;
  75. {
  76.     breakloop("break","return from BREAK",emsg,arg,TRUE);
  77. }
  78.  
  79. /* xlfail - xlisp error handler */
  80. xlfail(emsg)
  81.   char *emsg;
  82. {
  83.     xlerror(emsg,s_unbound);
  84. }
  85.  
  86. /* xlerror - handle a fatal error */
  87. xlerror(emsg,arg)
  88.   char *emsg; LVAL arg;
  89. {
  90.     if (getvalue(s_breakenable) != NIL)
  91.     breakloop("error",NULL,emsg,arg,FALSE);
  92.     else {
  93.     xlsignal(emsg,arg);
  94.     xlerrprint("error",NULL,emsg,arg);
  95.     xlbrklevel();
  96.     }
  97. }
  98.  
  99. /* xlcerror - handle a recoverable error */
  100. xlcerror(cmsg,emsg,arg)
  101.   char *cmsg,*emsg; LVAL arg;
  102. {
  103.     if (getvalue(s_breakenable) != NIL)
  104.     breakloop("error",cmsg,emsg,arg,TRUE);
  105.     else {
  106.     xlsignal(emsg,arg);
  107.     xlerrprint("error",NULL,emsg,arg);
  108.     xlbrklevel();
  109.     }
  110. }
  111.  
  112. /* xlerrprint - print an error message */
  113. xlerrprint(hdr,cmsg,emsg,arg)
  114.   char *hdr,*cmsg,*emsg; LVAL arg;
  115. {
  116.     /* print the error message */
  117.     sprintf(buf,"%s: %s",hdr,emsg);
  118.     errputstr(buf);
  119.  
  120.     /* print the argument */
  121.     if (arg != s_unbound) {
  122.     errputstr(" - ");
  123.     errprint(arg);
  124.     }
  125.  
  126.     /* no argument, just end the line */
  127.     else
  128.     errputstr("\n");
  129.  
  130.     /* print the continuation message */
  131.     if (cmsg) {
  132.     sprintf(buf,"if continued: %s\n",cmsg);
  133.     errputstr(buf);
  134.     }
  135. }
  136.  
  137. #ifdef WINTERP
  138. /*
  139.  * This version of breakloop() works with server in winterp.c. It allows you
  140.  * to be in the breakloop while X Events and Xlisp server requests to be
  141.  * processed.
  142.  */
  143. LOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
  144.      char *hdr,*cmsg,*emsg; LVAL arg; int cflag;
  145. {
  146.   extern int read_eval_print_just_called; /* from winterp.c */
  147.   extern int lisp_reader_hit_eof; /* from winterp.c */
  148.   extern XtAppContext app_context; /* from winterp.c */
  149.   LVAL expr,val;
  150.   CONTEXT cntxt;
  151.   int type;
  152.   XEvent event;
  153.  
  154.   xlerrprint(hdr,cmsg,emsg,arg); /* print the error message */
  155.  
  156.   /* flush the input buffer --  needed if using (read)/(read-line) from stdin */
  157.   xlflush();
  158.  
  159.   if (getvalue(s_tracenable)) {    /* do the back trace */
  160.     val = getvalue(s_tlimit);
  161.     xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
  162.   }
  163.   xlsave1(expr);        /* protect some pointers */
  164.   ++xldebug;            /* increment the debug level */
  165.  
  166.   read_eval_print_just_called = TRUE; /* special initial cond */
  167.   lisp_reader_hit_eof = FALSE;
  168.  
  169.   /* debug command processing loop -- note similarity to loop winterp.c:main() */
  170.   xlbegin(&cntxt,CF_BRKLEVEL|CF_CLEANUP|CF_CONTINUE,true);
  171.   for (type = 0; type == 0; ) {
  172.     /* 
  173.      * We need to setup a new error return only after each time that an XLISP 
  174.      * evaluation occurs. Therefore, we check for read_eval_print_just_called 
  175.      * (which is set by Read_Eval_Print()) and then clear it once the setjmp() 
  176.      * has been done. This avoids setting up an error return for each X event
  177.      * being processed in this loop. 
  178.      */
  179.     if (read_eval_print_just_called) { /* set in winterp.c:Read_Eval_Print callback */
  180.       read_eval_print_just_called = FALSE;
  181.       if (lisp_reader_hit_eof) {    /* set in winterp.c:Read_Eval_Print callback */
  182.     type = CF_CLEANUP;
  183.     break;
  184.       }
  185.       if (type = setjmp(cntxt.c_jmpbuf)) /* setup the continue trap */
  186.     switch (type) {
  187.     case CF_CLEANUP:
  188.       continue;
  189.     case CF_BRKLEVEL:
  190.       type = 0;
  191.       break;
  192.     case CF_CONTINUE:
  193.       if (cflag) {
  194.         dbgputstr("[ continue from break loop ]\n");
  195.         continue;
  196.       }
  197.       else 
  198.         xlabort("this error can't be continued");
  199.     }
  200.       sprintf(buf, "XLisp-Breakloop-Level-%d> ", xldebug); /* print a "prompt" */
  201.       dbgputstr(buf);
  202.       fflush(stdout); fflush(stderr); /* otherwise output won't happen while blocked in XtAppNextEvent() */
  203.     }
  204.  
  205.     /*
  206.      * XtAppNextEvent() waits for Xevents, and while it is waiting, it will
  207.      * process inputs added via AtAppAddInput() or XtAppAddWorkProc(). Lisp 
  208.      * server input will cause Read_Eval_Print() to get called, and that
  209.      * procedure sets the globals lisp_reader_hit_eof and 
  210.      * read_eval_print_just_called. Read_Eval_Print() sends a bogus 
  211.      * XAnyEvent (event.type == 0) so as to force XtAppNextEvent() to return; 
  212.      * otherwise it would only return if a lisp evaluation caused X events 
  213.      * to be generated, which means that XLISP error returns for non-X 
  214.      * evaluations wouldn't get set up properly.
  215.      *
  216.      * XtDispatchEvent() will dispatch the actions from the events gathered
  217.      * by XtAppNextEvent(). Note that XtAppNextEvent() ignores the aforementioned
  218.      * bogus events: "if (event->type == 0) return;"
  219.      */
  220.     XtAppNextEvent(app_context, &event);
  221.     XtDispatchEvent(&event);
  222.   }
  223.   xlend(&cntxt);
  224.  
  225.   --xldebug;            /* decrement the debug level */
  226.   xlpop();            /* restore the stack */
  227.   if (type == CF_CLEANUP)    /* check for aborting to the previous level */
  228.     xlbrklevel();
  229. }
  230.  
  231. #else
  232.  
  233. /* breakloop - the debug read-eval-print loop */
  234. LOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
  235.   char *hdr,*cmsg,*emsg; LVAL arg; int cflag;
  236. {
  237.     LVAL expr,val;
  238.     CONTEXT cntxt;
  239.     int type;
  240.  
  241.     /* print the error message */
  242.     xlerrprint(hdr,cmsg,emsg,arg);
  243.  
  244.     /* flush the input buffer */
  245.     xlflush();
  246.  
  247.     /* do the back trace */
  248.     if (getvalue(s_tracenable)) {
  249.     val = getvalue(s_tlimit);
  250.     xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
  251.     }
  252.  
  253.     /* protect some pointers */
  254.     xlsave1(expr);
  255.  
  256.     /* increment the debug level */
  257.     ++xldebug;
  258.  
  259.     /* debug command processing loop */
  260.     xlbegin(&cntxt,CF_BRKLEVEL|CF_CLEANUP|CF_CONTINUE,true);
  261.     for (type = 0; type == 0; ) {
  262.  
  263.     /* setup the continue trap */
  264.     if (type = setjmp(cntxt.c_jmpbuf))
  265.         switch (type) {
  266.         case CF_CLEANUP:
  267.         continue;
  268.         case CF_BRKLEVEL:
  269.         type = 0;
  270.         break;
  271.         case CF_CONTINUE:
  272.         if (cflag) {
  273.             dbgputstr("[ continue from break loop ]\n");
  274.             continue;
  275.         }
  276.         else xlabort("this error can't be continued");
  277.         }
  278.  
  279.     /* print a prompt */
  280.     sprintf(buf,"%d> ",xldebug);
  281.     dbgputstr(buf);
  282.  
  283.     /* read an expression and check for eof */
  284.     if (!xlread(getvalue(s_debugio),&expr,FALSE)) {
  285.         type = CF_CLEANUP;
  286.         break;
  287.     }
  288.  
  289.     /* save the input expression */
  290.     xlrdsave(expr);
  291.  
  292.     /* evaluate the expression */
  293.     expr = xleval(expr);
  294.  
  295.     /* save the result */
  296.     xlevsave(expr);
  297.  
  298.     /* print it */
  299.     dbgprint(expr);
  300.     }
  301.     xlend(&cntxt);
  302.  
  303.     /* decrement the debug level */
  304.     --xldebug;
  305.  
  306.     /* restore the stack */
  307.     xlpop();
  308.  
  309.     /* check for aborting to the previous level */
  310.     if (type == CF_CLEANUP)
  311.     xlbrklevel();
  312. }
  313.  
  314. #endif
  315.  
  316. /* baktrace - do a back trace */
  317. xlbaktrace(n)
  318.   int n;
  319. {
  320.     LVAL *fp,*p;
  321.     int argc;
  322.     for (fp = xlfp; (n < 0 || n--) && *fp; fp = fp - (int)getfixnum(*fp)) {
  323.     p = fp + 1;
  324.     errputstr("Function: ");
  325.     errprint(*p++);
  326.     if (argc = (int)getfixnum(*p++))
  327.         errputstr("Arguments:\n");
  328.     while (--argc >= 0) {
  329.         errputstr("  ");
  330.         errprint(*p++);
  331.     }
  332.     }
  333. }
  334.  
  335. /* xldinit - debug initialization routine */
  336. xldinit()
  337. {
  338.     xlsample = 0;
  339.     xldebug = 0;
  340. }
  341.  
  342.